home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Dr. Windows 3
/
dr win3.zip
/
dr win3
/
WINPROGS
/
ABOUTBOX.ZIP
/
ABOUTBOX.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-05-19
|
9KB
|
327 lines
{ About box unit, from PC Mag, June 15, 1993 }
unit AboutBox;
interface
uses WinProcs, WinTypes, Objects, OWindows, ODialogs;
{$R About.res }
const
idShade = 100;
idBump = 101;
idHotKey = 103;
type
ppCharArray = ^tpCharArray;
tpCharArray = array[0..65520 div sizeof(pChar)] of pChar;
pCreditWindow = ^tCreditWindow;
tCreditWindow = object(tWindow)
BitMap : hBitmap;
BitSize : tBitmap;
ScrollUnit : integer;
Scrollrate : integer;
ScrollPos : integer;
Fontheight : integer;
StringList : ppCharArray;
StringCount : word;
constructor Init(Aparent : pWindowsObject;
ABitmapName : pChar;
const AStringList : array of pChar);
destructor Done; virtual;
function GetClassName : pChar; virtual;
procedure GetWindowClass(var AWndClass : tWndClass); virtual;
procedure SetUpWIndow; virtual;
procedure WMDestroy(var Msg : TMessage);
virtual wm_First + wm_Destroy;
procedure Paint(DC : hDC; var PS : tPaintStruct); virtual;
procedure ShowCredits; virtual;
procedure WMTImer(var Msg : TMessage);
virtual wm_First + wm_Timer;
end;
pAboutBox = ^tAboutBox;
tAboutBox = object(tDialog)
Title : pChar;
CreditWindow : pCreditWindow;
constructor Init(AParent : pWindowsObject;
ATitle,ABitMapName : pChar;
const AStringList : array of pChar);
destructor Done; virtual;
procedure SetUpWindow; virtual;
function GetResName : pChar; virtual;
procedure InitCreditWindow(ABitMapName : pChar;
const AStringList : array of pChar);
virtual;
procedure ShowCRedits(var Msg : TMessage);
virtual id_First + idHotKey;
end;
implementation
uses Strings;
constructor tCreditWindow.Init;
var
DC : hDC;
OldFont : hFOnt;
TM : tTextMetric;
begin
inherited Init(Aparent,nil);
Attr.Style := ws_Child or ws_Visible;
Bitmap := LoadBitMap(hInstance,ABitMapName);
if BitMap = 0 then
begin
Status := em_InvalidWindow;
Exit;
end;
GetObject(Bitmap,sizeof(BitSize),@BitSize);
ScrollPos := 0;
DC := GetDC(0);
ScrollUnit := 2;
ScrollRate := 80;
OldFont := SelectObject(DC,GetStockObject(ANSI_VAR_FONT));
GetTextMetrics(DC,TM);
FontHeight := TM.tmHeight + TM.tmExternalLeading + 5;
SelectObject(DC,OldFont);
ReleaseDC(0,DC);
StringList := @AStringList;
StringCount := high(AStringList);
end;
destructor tCreditWIndow.Done;
begin
inherited Done;
DeleteObject(Bitmap);
end;
function tCreditWindow.GetClassName : pChar;
begin
GetClassName := 'TNHAboutMap';
end;
procedure tCreditWindow.GetWindowClass;
begin
inherited GetWindowClass(AWndClass);
AWndClass.Style := cs_ByteAlignWindow;
AWndClass.hbrBackGround := GetStockObject(Black_Brush);
end;
procedure tCreditWindow.SetUpWindow;
begin
inherited SetUpWindow;
SetWIndowPos(hWIndow,0,0,0,BitSize.bmWidth,BitSize.bmHeight,
swp_NoMove or swp_NoZOrder or swp_NoACtivate or swp_NoRedraw);
end;
procedure tCreditWindow.WMDestroy;
begin
if SCrollPos <> 0 then
begin
KillTimer(HWindow,1);
SCrollPos := 0;
end;
inherited WMDestroy(Msg);
end;
procedure tCreditWindow.Paint;
var
R : TRect;
FirstLine,LastLine,Y : integer;
procedure DrawBitMap(Y : integer);
var
MemDC : hDC;
OldBits : hBitmap;
begin
MemDC := CreateCompatibleDC(DC);
OldBits := SelectObject(MemDC,Bitmap);
BitBlt(DC,0,Y,Attr.W,Attr.H,MemDC,0,0,srcCopy);
SelectObject(MemDC,OldBits);
DeleteDC(DC);
end;
begin
SaveDC(DC);
SetViewPortOrg(DC,0,-ScrollPos);
OffsetRect(PS.rcPaint,0,SCrollPos);
with R do
begin
Left := 0; Top := 0;
Right := Attr.W; Bottom := Attr.H;
end;
if Bool(IntersectRect(R,PS.rcpaint,R)) then
begin
DrawBitmap(0);
with PS.rcPaint do
begin
if (R.Top < Top) and (R.Bottom > Top) then Top := Bottom;
if (R.Top < Bottom) and (R.Bottom > Bottom) then Bottom := R.Top;
if Top > Bottom then TOp := Bottom;
end;
end;
if ScrollPos > 0 then
begin
FirstLine := (PS.rcPaint.Top - Attr.H) div FontHeight;
if FirstLine < 0 then FirstLine := 0;
if FirstLine < StringCount then
begin
SetTextAlign(DC,TA_Center);
SetBKColor(DC,0);
SetTextColor(DC,RGB($FF,$FF,$FF));
LastLine := (PS.rcPaint.Bottom - Attr.H) div FOntHeight;
for Y := FirstLine to LastLine do
if Y < StringCount then
TextOut(DC,Attr.W div 2,Y * FontHeight + Attr.H,
StringList^[Y],strlen(StringList^[Y]));
end;
if PS.rcPaint.Bottom > (Attr.H + Fontheight * StringCount) then
DrawBitmap(Attr.H + FontHeight * StringCount);
end;
RestoreDC(DC, -1);
end; { paint }
procedure tCreditWindow.ShowCredits;
begin
SetTimer(HWindow,1,ScrollRate,nil);
end;
procedure tCreditWindow.WMTImer;
begin
inc(ScrollPos,SCrollUnit);
if SCrollPos > Attr.H + FontHeight * StringCount then
begin
SCrollPos := 0;
KillTimer(Hwindow,1);
InvalidateRect(HWindow,nil,FALSE);
end
else
SCrollWindow(HWIndow,0,-SCrollUnit,nil,nil);
UpDateWindow(HWIndow);
end;
constructor tAboutBox.Init;
begin
inherited Init(AParent,GetResName);
Title := Strnew(Atitle);
InitCreditWindow(ABitMapName,AStringList);
end;
destructor tAboutBox.Done;
begin
inherited Done;
if Title <> nil then StrDispose(Title);
end;
procedure tAboutBox.SetUpWindow;
var
RDialog,R,RBitWnd,RShade,RBump,ROK : TRect;
X8,Y8 : integer;
DC : hDc;
begin
inherited SetUpWindow;
SetWindowText(Hwindow,Title);
Dc := GetDC(Hwindow);
X8 := GetDeviceCaps(DC,LogPixelsX) div 8;
Y8 := GetDeviceCaps(DC,LogPixelsY) div 8;
ReleaseDC(Hwindow,DC);
GetClientRect(GetDlgItem(HWIndow,idShade),RShade);
GetClientRect(GetDlgItem(HWIndow,idBump),RBump);
GetClientRect(GetDlgItem(HWIndow,idOK),ROK);
GetClientRect(CreditWindow^.HWindow,RBitWnd);
RShade.Top := Y8;
RShade.Left := X8;
if RShade.Right < RBitWnd.Right + (2 * X8) then
RShade.Right := RBitWnd.Right + 2 * X8;
if RShade.Bottom < rBitWnd.Bottom + 2 * Y8 then
RShade.Bottom := RBitWnd.Bottom + 2 * Y8;
with RDialog do
begin
GetWindowRect(Hwindow,RDialog);
GetClientRect(HWindow,R);
Right := Right - Left - R.Right;
Bottom := Bottom - Top - R.Bottom;
Right := Right + X8 + RShade.Right + X8;
Bottom := Bottom + Y8 + RShade.Bottom
+ Y8 + RBump.Bottom
+ Y8 + ROk.Bottom + Y8;
if Parent <> nil then
begin
GetWindowRect(Parent^.Hwindow,R);
Left := R.Left + (R.Right - R.Left) div 2 - Right div 2;
Top := R.Top + (R.Bottom - R.Top) div 2 - Bottom div 2;
end;
SetWindowPos(HWindow,0,Left,Top,Right,Bottom,swp_NoActivate or swp_NoZOrder);
end;
with RShade do
begin
SetWindowPos(GetDlgItem(HWindow,idShade),0,Left,Top,Right,Bottom,
swp_NoACtivate